perm filename SMALLX.FAI[XX,LCS] blob sn#195538 filedate 1976-01-02 generic text, type T, neo UTF8
00100		TITLE SMALL
00200		INTERNAL RJBX,CENTX,EXTEN,JDRAW,CENTER,LINX,UNPACK,ROFF,NOIR
00300		INTERNAL NOZERO,EXCH,BMS,IABS,RHORZ,ABS,RTLINE,FLOAT,IFIX
00400		EXTERNAL .COMM.,STF,POSI,LL,LINES,BM,XRN,PTR,AMOD,MOD,PLOT
00450		EXTERNAL PLTR,SQRT
00500	;;	DEFINE FLOAT(N)
00600	;; <	TLC N,232000
00700	;;	FADR N,N   >
00800		DEFINE FIXX(N)
00900	<	JUMPGE	N,.+5
01000		MOVNS	N
01100		FIX 	N,233000    
01200		MOVNS	N
01300		CAIA
01400		FIX	N,233000 >	; TO FIX IT LIKE 'IFIX' DOES.
01500	
01600	
01700	
01800	RJBX:	0		;R3=R3+R*RSTJ2
01900		MOVE 2,@(16)
02000		FMPR 	2,STF+=8
02100		FADRM	2,.COMM.+=4
02200		JRA	16,1(16)
02300	
02400	CENTX:	0	;CENTX=POS-18.*RSTJ2+AMOD(R4,100.0)*RSTJ2*7.
02500		JSA 	16,AMOD
02600		JUMP	.COMM.+5
02700		JUMP	[=100.0]
02800		MOVEM .COMM.+5		;[R4=AMOD(R4,100.0)]
02900		FMPR	[=7.0]
03000		FSBR	[=18.0]
03100		FMPR	STF+=8
03200		FADR	POSI+=9
03400		MOVEM	.COMM.+2
03500		JRA	16,(16)
03600	
03700	
03800	EXTEN:	0	;FUNCTION EXTEN(X)
03900		HRRM	16,.+2
04000		JSA	16,AMOD	;EXTEN=AMOD(X,1.)*10.
04100		JUMP 	@0
04200		JUMP	[=1.0]
04300		FMPR	[=10.0]
04400		JRA	16,1(16)
04500	
04600	
04700	AA:	0
04800	BB:	0
04900	CC:	0
05000	DD:	0
05100	
05200	JDRAW:	0	;SUBROUTINE JDRAW(M,R3,CENTR,RSTJ2,RX,RY)
05300		MOVE	2,@3(16)	;COMMON/LL/LL
05400		MOVE	13,@4(16)	;DIMENSION M(1)
05500		FMPR	13,2		;RC=RX*RSTJ2
05600		MOVE	14,@5(16)	;RD=RY*RSTJ2
05700		FMPR	14,2	;13 HAS RC,  14 HAS RD
05800		MOVE	3,@(16)		;DO 2 K=2,M(1)
05900		HRRZ	12,(16)  ; BRING IN ADR. OF M (ZERO LEFT HALF)
06000		MOVE	10,(12)		;PUT ADR. OF M IN 10
06100		ADDI	10,-1(12)
06200	L2:	AOJ	12,	; SET UP LOOP
06300		CAILE	12,(10)	; SEE IF WE'VE PASSED END OF LOOP
06400		JRA	16,6(16)	; GO HOME
06500		HRRZM	12,.+4	; PUT ADR. OF VALUE M(K) IN LAST JUMP
06600	; CALL UNPACK(A,B,M(K))
06700		JSA	16,UNPACK
06800		JUMP	AA
06900		JUMP	BB
07000		JUMP
07100	;2  CALL LINES(FLOAT(A)*RC+R3,FLOAT(B)*RD+CENTR,LL)
07200	;;	JSA	16,FLOAT
07300	;;	JUMP	AA
07400		MOVE 0,AA
07500	   	TLC 	0,232000
07600		FADR 	0,0   
07700		FMPR	13
07800		FADR	@1(16)
07900		MOVEM	AA
08000	;;	JSA	16,FLOAT
08100	;;	JUMP	BB
08200		MOVE 0,BB
08300	   	TLC 	0,232000
08400		FADR 	0,0   
08500		FMPR	14
08600		FADR	@2(16)
08700		MOVEM	BB
08800		JSA	16,LINES
08900		JUMP	AA
09000		JUMP	BB
09100		JUMP	LL
09200		JRST	L2
09300	
09400	CENTER:	0    ;	SUBROUTINE CENTER(CNTR)
09500	;  TO CENTER ITEMS CREATED WITH DRAWING PROG.
09600		;	COMMON /STF/RSTFAC(8),RSTJ2
09700		;	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
09800		;	COMMON/POSI/STF(8),JJ2,POS
09900		;	EQUIVALENCE (R4,RJQ(2))
10000		JSA	16,AMOD    ;CNTR=POS+(2+AMOD(R4,100.)*7)*RSTJ2
10100		JUMP	.COMM.+5
10200		JUMP	[=100.0]
10300		FMPR	[=7.0]
10400		FADR	[=2.0]
10500		FMPR	STF+=8
10600		FADR	POSI+=9
10700		MOVEM	@(16)
10800		JRA	16,1(16)
10900	
11000	LINX:	0	; SUBROUTINE LINX(A,B,C,D)
11100	; C  SAVES SPACE FOR SINGLE LINES.
11200		MOVE	@(16)	;CALL LINES(A,B,3)
11300		MOVEM	AA
11400		MOVE	@1(16)
11500		MOVEM	BB
11600		MOVE	@2(16) ;CALL LINES(C,D,2)
11700		MOVEM	CC
11800		MOVE	@3(16)
11900		MOVEM	DD
12000		JSA	16,LINES
12100		JUMP	AA
12200		JUMP	BB
12300		JUMP	[=3]
12400		JSA	16,LINES
12500		JUMP	CC
12600		JUMP	DD
12700		JUMP	[=2]
12800		JRA	16,4(16)
12900	
13000	UNPACK:	0  ;	SUBROUTINE UNPACK(M,N,I)
13100		;	COMMON/LL/L
13200	;C  L IS FOR VIS. OR INVIS. LINES.
13300	 	MOVE	@2(16)	; N=I
13400		MOVE	3,
13500		IDIV	[=100000000]  ;  M=N/100000000
13600		JUMPE	O2	; IF(M.EQ.0)GO TO 2
13700		MOVEI	2,3	; L=3
13800		IMUL	[=100000000]	; N=N-100000000*M
13900		MOVNS
14000		ADD	3,0	; 3 HAS N, 4 HAS M(LATER)
14100		JRST	M2
14200	O2:	MOVEI	2,2	; L=2
14300	M2:	MOVE	4,3
14400		IDIVI	4,23420    ;2	M=N/10000
14500		MOVEM	2,LL	; PUTS AWAY L
14600		MOVEM	3,AA
14700		JSA	16,MOD   ; N=MOD(N,10000)
14800		JUMP	AA
14900		JUMP	[=10000]
15000		MOVEI	2,1750	; IF(M.GT.1000)M=1000-M
15100		CAML	2,4
15200		JRST	N2
15300		MOVEI	2,1750
15400		MOVNS	4
15500		ADD	4,2
15600	N2:	CAML	2,	; IF(N.GT.1000)N=1000-N
15700		JRST	P2
15800		MOVNS
15900		ADD	2
16000	P2:	MOVEM	4,@(16)
16100		MOVEM	0,@1(16)
16200		JRA	16,3(16)
16300	
16400	ROFF:	0	; FUNCTION ROFF(R)
16500		MOVSI	200400   ; S=.5
16600		SKIPGE	1,@(16)   ; IF(R)S=-S
16700		MOVNS
16800		FADR	1   ; ROFF=R+S
16900		JRA	16,1(16)
17000	
17100	NOZERO:	0	;SUBROUTINE NOZERO(X)
17200		SKIPE	@(16)	; IF(X.EQ.0)X=1
17300		JRA	16,1(16)
17400		MOVE	[=1.0]	; MAKE ALL ZEROS INTO ONES.
17500		MOVEM	@(16)
17600		JRA	16,1(16)
17700	
17800	EXCH:	0	; SUBROUTINE EXCH(X,Y)
17900		MOVE	@(16)
18000		EXCH	0,@1(16)
18100		MOVEM	0,@(16)
18300		JRA	16,2(16)
18400	
18500	BMS:	0    	;	SUBROUTINE BMS
18600		MOVE	BM+1 ;COMMON/STF/RSTFAC(-3/4),RSTJ2/BM/RA,RC,RKY
18700		FMPR	STF+=8	; CALL LINES(RA,RJY+RC*RSTJ2,2)
18800		FADR	BM+2
18900		MOVEM	BB
19000		JSA	16,LINES	;	END
19100		JUMP	BM
19200		JUMP	BB
19300		JUMP	[2]
19400		JRA	16,(16)
19500	
19600	IABS:	0     		; FUNCTION IABS(N)
19700	 	MOVM 0,@(16)  ;BECAUSE IABS IN LIB40 HAS A BUG.
19800		JRA	16,1(16)    	; IABS=N  ; IF(N)IABS=-N
19900	
20000	RHORZ:	0  		; FUNCTION RHORZ(R)
20100		MOVE	@(16)  	; RHORZ=R*5.96-596.
20200		FMPR	[=5.96]
20300		FSBR	[=596.0]
20400		JRA	16,1(16)
20500	
20600	ABS:	0
20700		JRST	IABS+1
20800	
20900	RTLINE:	0	;FUNCTION RTLINE(L)
21000		MOVE 2,.COMM. ;COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)/XRN/RN(4000)
21100		CAMLE	2,[=4.0] ;RTLINE=-1
21200		JRST 	ZRO	;IF(R2.GT.4)GO TO 1
21300	;;	HRRZ	@(16)	;IF(RN(L+2).NE.R2)RETURN
21350		MOVE 3,@(16)
21400	;;	HRRZI	3,XRN  ; PUT ADR. OF XRN IN 3
21500	;;	ADD	3,  ; 1  RTLINE=0
21600		SETO
21700	;;	CAMN	2,1(3)
21750		CAMN 2,XRN+1(3)
21800	ZRO:	SETZ
21900		JRA	16,1(16)
22000	
22100	FLOAT: 	0
22200		MOVE	0,@(16)
22300	   	TLC 	0,232000
22400		FADR 	0,0   
22500		JRA	16,1(16)
22600	IFIX:   0
22700		MOVE	0,@(16)
22800		JUMPGE	0,.+5
22900		MOVNS	0
23000		FIX 	0,233000    
23100		MOVNS	0
23200		CAIA
23300		FIX	0,233000
23400		JRA	16,1(16)
23500	
23600	;;;MOD:	0
23700	;;;	MOVE	2,@(16)
23800	;;;	IDIV	2,@1(16)
23900	;;;	IMUL	2,@1(16)
24000	;;;	MOVE	@(16)
24100	;;;	SUB	2
24200	;;;	JRA	16,2(16)
24300	
24400	J←10↔ A←2↔ B←3↔ C←4↔ D←5↔ E←6↔  N←11↔NX←12 ; SUBROUTINE NOIR(RMINI)
24500	Y←13↔ X←14↔ L←15↔ M←1
24600	JPOS:	0		;C  BLACKS IN NOTES
24700	IPOS:	0	;COMMON R2,JA,CENTR,J2,RJQ(20),JQ(12),B,C,KC,D,N,JY,M,L
24800	IC:	0
24900	K:	0
25000	NOIR:	0    ;	COMMON/PLTR/IPLT,RHT,DIS /XRN/IRN(4000)
25100		MOVE	A,.COMM.+4		;EQUIVALENCE (PRE,IRN(1))
25200		FMPR	A,PLTR+2	;DATA BL/7.5/,BH/6.7/
25300	;  ADJUST BH AND FL FOR HEIGHT OF NOTE AND 'WIDTH'
25400		JSA	16,ROFF		;IPOS=ROFF(RJQ(1)*DIS)
25500		JUMP	A
25600		FIXX(A)
25700		MOVEM	A,IPOS
25800		MOVE	A,.COMM.+2		;JPOS=ROFF(CENTR*RHT)
25900		FMPR	A,PLTR+1
26000		JSA	16,ROFF
26100		JUMP	A
26200		FIXX(A)	
26210	;??	MOVE 	D,@(16)
26220	;??	CAME	D,STF+8		;IF(RMINI.NE.RSTJ2)JPOS=JPOS+1
26250	;??	AOS A	;TO PUSH MINI-NOTE UP ONE XGP NOTCH!!!! *******************
26300		MOVEM	A,JPOS		;SAVE FOR LATER
26400		MOVN	A,@(16)		;IF(-RMINI.EQ.PRE)GO TO 10
26500		CAMN	A,XRN
26600		JRST	NO10
26700		MOVEM	A,XRN		;PRE=-RMINI
26800		MOVE	D,[=0.25]	;D=.25
26900		MOVE	B,[=6.7]	;B=BH*RMINI*RHT
27000		FMPR	B,PLTR+1
27100		FMPR	B,@(16)
27200		MOVE	E,PLTR+2	;E=RMINI*DIS
27300		FMPR	E,@(16)
27400		MOVE	A,[=7.5]	;A=BL*E
27500		FMPR	A,E
27600		MOVE	15,A
27700		FIXX(15)		;IC=A
27800		MOVEM	15,IC
27900		FMPR	A,A		;A=A*A
28000		MOVN	E,B		;E=-B/4.
28100		FDVR	E,[=4.0]
28200		MOVE	15,B		;K=B
28300		FIXX(15)
28400		MOVEM	15,K
28500		FMPR	B,B		;B=B*B
28600	;  USES EQUATION FOR ELLIPSE
28700		MOVEI	11,1		;N=1
28800		MOVEI	NX,2		;NX=2
28900		MOVN	J,K	;6	DO 1 J=-K,K
29000	NO1:	MOVE	Y,J		;Y=J*J
29100		IMUL	Y,Y
29200		TLC	Y,232000
29300		FADR	Y,Y		;FLOAT
29400		MOVN	X,Y		;X=SQRT(A-(A*Y)/B)
29500		FMPR	X,A
29600		FDVR	X,B
29700		FADR	X,A
29800		JSA	16,SQRT
29900		JUMP	X
30000		MOVE	X,0
30100		MOVE	L,E		;L=E-X
30200		FSBR	L,X
30300		FIXX(L)
30400		MOVE	M,X		;M=X+E
30500		FADR	M,E
30600		FIXX(M)		;  THE TWO SIDES OF THE LINE
30700		SKIPGE	11		;IF(N)CALL EXCH(L,M)
30800		EXCH	L,M
30900	;;	HRRZI	7,XRN		;IRN(NX)=L
31000	;;	ADDI	7,(NX)
31100	;;	MOVEM	L,-1(7)
31200	;;	MOVEM	M,(7)		;IRN(NX+1)=M
31210		MOVEM L,XRN-1(NX)
31220		MOVEM M,XRN(NX)
31300	;     C IS VERTICLE POS.
31400		ADDI	NX,2		;NX=NX+2
31500		FADR	E,D		;E=E+D
31600	;   E IS TO TILT IT.
31700		MOVNS	11	;1	N=-N
31800		CAMGE	J,K
31900		AOJA	J,NO1		;LOOP BACK
32000	NO10:	MOVE	J,IPOS	;10	CALL PLOT(IPOS+3,JPOS,3)
32100		ADDI	J,3
32200		JSA	16,PLOT
32300		JUMP	J
32400		JUMP 	JPOS
32500		JUMP	[3]
32600		MOVEI	11,2		;N=2
32700	;   1ST LOC. OF ARRAY HAS "PRE"
32800		MOVE	L,IC		;L=IPOS+IC
32900		ADD	L,IPOS
33000		MOVN	M,K		;DO 11 M=-K,K
33100	NO11:	MOVE	J,JPOS		;J=M+JPOS
33150		MOVEM	M,AA
33200		ADD	J,M
33300	;;	HRRZI	X,XRN		;CXLL PLOT(L+IRN(N),J,2)
33400	;;	ADDI	X,(11)
33500	;;	MOVE	NX,-1(X)
33510		MOVE NX,XRN-1(11)
33600		ADD	NX,L
33700		JSA 	16,PLOT
33800		JUMP	NX
33900		JUMP	J
34000		JUMP	[2]
34100	;;	MOVE 	NX,(X)		;CXLL PLOT(L+IRN(N+1),J,2)
34110		MOVE NX,XRN(11)
34200		ADD	NX,L
34300		JSA	16,PLOT
34400		JUMP	NX
34500		JUMP	J
34600		JUMP	[2]
34700		ADDI	11,2		;11	N=N+2
34750		MOVE	M,AA
34800		CAMGE	M,K
34900		AOJA	M,NO11
35000		JRA	16,1(16)
35100	
35200		END